home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / gnu / emacs.lha / emacs-19.16 / lisp / lisp-mnt.el < prev    next >
Text File  |  1993-04-13  |  14KB  |  435 lines
  1. ;;; lisp-mnt.el --- minor mode for Emacs Lisp maintainers
  2.  
  3. ;; Copyright (C) 1992 Free Software Foundation, Inc.
  4.  
  5. ;; Author: Eric S. Raymond <esr@snark.thyrsus.com>
  6. ;; Maintainer: Eric S. Raymond <esr@snark.thyrsus.com>
  7. ;; Created: 14 Jul 1992
  8. ;; Version: $Id: lisp-mnt.el,v 1.3 1993/04/14 03:34:42 eric Exp $
  9. ;; Keywords: docs
  10. ;; Bogus-Bureaucratic-Cruft: Gruad will get you if you don't watch out!
  11.  
  12. ;; This file is part of GNU Emacs.
  13.  
  14. ;; GNU Emacs is free software; you can redistribute it and/or modify
  15. ;; it under the terms of the GNU General Public License as published by
  16. ;; the Free Software Foundation; either version 1, or (at your option)
  17. ;; any later version.
  18.  
  19. ;; GNU Emacs is distributed in the hope that it will be useful,
  20. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  21. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  22. ;; GNU General Public License for more details.
  23.  
  24. ;; You should have received a copy of the GNU General Public License
  25. ;; along with GNU Emacs; see the file COPYING.  If not, write to
  26. ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  27.  
  28. ;;; Commentary:
  29.  
  30. ;; This minor mode adds some services to Emacs-Lisp editing mode.
  31. ;;
  32. ;; First, it knows about the header conventions for library packages.
  33. ;; One entry point supports generating synopses from a library directory.
  34. ;; Another can be used to check for missing headers in library files.
  35. ;; 
  36. ;; Another entry point automatically addresses bug mail to a package's
  37. ;; maintainer or author.
  38.  
  39. ;; This file can be loaded by your lisp-mode-hook.  Have it (require 'lisp-mnt)
  40.  
  41. ;; This file is an example of the header conventions.  Note the following
  42. ;; features:
  43. ;; 
  44. ;;    * Header line --- makes it possible to extract a one-line summary of
  45. ;; the package's uses automatically for use in library synopses, KWIC
  46. ;; indexes and the like.
  47. ;; 
  48. ;;    Format is three semicolons, followed by the filename, followed by
  49. ;; three dashes, followed by the summary.  All fields space-separated.
  50. ;; 
  51. ;;    * Author line --- contains the name and net address of at least
  52. ;; the principal author.
  53. ;; 
  54. ;;    If there are multiple authors, they should be listed on continuation
  55. ;; lines led by ;;<TAB>, like this:
  56. ;; 
  57. ;; ;; Author: Ashwin Ram <Ram-Ashwin@cs.yale.edu>
  58. ;; ;;    Dave Sill <de5@ornl.gov>
  59. ;; ;;    David Lawrence <tale@pawl.rpi.edu>
  60. ;; ;;    Noah Friedman <friedman@ai.mit.edu>
  61. ;; ;;    Joe Wells <jbw@maverick.uswest.com>
  62. ;; ;;    Dave Brennan <brennan@hal.com>
  63. ;; ;;    Eric Raymond <esr@snark.thyrsus.com>
  64. ;; 
  65. ;; This field may have some special values; notably "FSF", meaning
  66. ;; "Free Software Foundation".
  67. ;; 
  68. ;;    * Maintainer line --- should be a single name/address as in the Author
  69. ;; line, or an address only, or the string "FSF".  If there is no maintainer
  70. ;; line, the person(s) in the Author field are presumed to be it.  The example
  71. ;; in this file is mildly bogus because the maintainer line is redundant.
  72. ;;    The idea behind these two fields is to be able to write a lisp function
  73. ;; that does "send mail to the author" without having to mine the name out by
  74. ;; hand. Please be careful about surrounding the network address with <> if
  75. ;; there's also a name in the field.
  76. ;; 
  77. ;;    * Created line --- optional, gives the original creation date of the
  78. ;; file.  For historical interest, basically.
  79. ;; 
  80. ;;    * Version line --- intended to give the reader a clue if they're looking
  81. ;; at a different version of the file than the one they're accustomed to.  This
  82. ;; may be an RCS or SCCS header.
  83. ;; 
  84. ;;    * Adapted-By line --- this is for FSF's internal use.  The person named
  85. ;; in this field was the one responsible for installing and adapting the
  86. ;; package for the distribution.  (This file doesn't have one because the
  87. ;; author *is* one of the maintainers.)
  88. ;; 
  89. ;;    * Keywords line --- used by the finder code (now under construction)
  90. ;; for finding elisp code related to a topic.
  91. ;;
  92. ;;    * Bogus-Bureaucratic-Cruft line --- this is a joke.  I figured I should
  93. ;; satirize this design before someone else did.  Also, it illustrates the
  94. ;; possibility that other headers may be added in the future for new purposes.
  95. ;;
  96. ;;    * Commentary line --- enables lisp code to find the developer's and
  97. ;; maintainers' explanations of the package internals.
  98. ;; 
  99. ;;    * Change log line --- optional, exists to terminate the commentary
  100. ;; section and start a change-log part, if one exists.
  101. ;; 
  102. ;;    * Code line --- exists so elisp can know where commentary and/or
  103. ;; change-log sections end.
  104. ;; 
  105. ;;    * Footer line --- marks end-of-file so it can be distinguished from
  106. ;; an expanded formfeed or the results of truncation.
  107.  
  108. ;;; Change Log:
  109.  
  110. ;; Tue Jul 14 23:44:17 1992    ESR
  111. ;;    * Created.
  112.  
  113. ;;; Code:
  114.  
  115. (require 'picture)        ; provides move-to-column-force
  116. (require 'emacsbug)
  117.  
  118. ;; These functions all parse the headers of the current buffer
  119.  
  120. (defun lm-section-mark (hd &optional after)
  121.   ;; Return the buffer location of a given section start marker
  122.   (save-excursion
  123.     (let ((case-fold-search t))
  124.       (goto-char (point-min))
  125.       (if (re-search-forward (concat "^;;; " hd ":$") nil t)
  126.       (progn
  127.         (beginning-of-line)
  128.         (if after (forward-line 1))
  129.         (point))
  130.     nil))))
  131.  
  132. (defun lm-code-mark ()
  133.   ;; Return the buffer location of the code start marker
  134.   (lm-section-mark "Code"))
  135.  
  136. (defun lm-header (hd)
  137.   ;; Return the contents of a named header
  138.     (goto-char (point-min))
  139.     (let ((case-fold-search t))
  140.       (if (re-search-forward
  141.        (concat "^;; " hd ": \\(.*\\)") (lm-code-mark) t)
  142.       (buffer-substring (match-beginning 1) (match-end 1))
  143.     nil)))
  144.  
  145. (defun lm-header-multiline (hd)
  146.   ;; Return the contents of a named header, with possible continuation lines.
  147.   ;; Note -- the returned value is a list of strings, one per line.
  148.   (save-excursion
  149.     (goto-char (point-min))
  150.     (let ((res (save-excursion (lm-header hd))))
  151.       (if res
  152.       (progn
  153.         (forward-line 1)
  154.         (setq res (list res))
  155.         (while (looking-at "^;;\t\\(.*\\)")
  156.           (setq res (cons (buffer-substring
  157.                    (match-beginning 1)
  158.                    (match-end 1))
  159.                   res))
  160.           (forward-line 1))
  161.         ))
  162.       res)))
  163.  
  164. ;; These give us smart access to the header fields and commentary
  165.  
  166. (defun lm-summary (&optional file)
  167.   ;; Return the buffer's or FILE's one-line summary.
  168.   (save-excursion
  169.     (if file
  170.     (find-file file))
  171.     (goto-char (point-min))
  172.     (prog1
  173.       (if (looking-at "^;;; [^ ]+ --- \\(.*\\)")
  174.       (buffer-substring (match-beginning 1) (match-end 1)))
  175.       (if file
  176.       (kill-buffer (current-buffer)))
  177.       )))
  178.  
  179.  
  180. (defun lm-crack-address (x)
  181.   ;; Given a string containing a human and email address, parse it
  182.   ;; into a cons pair (name . address).
  183.   (cond ((string-match "\\(.+\\) [(<]\\(\\S-+@\\S-+\\)[>)]" x)
  184.      (cons (substring x (match-beginning 1) (match-end 1))
  185.            (substring x (match-beginning 2) (match-end 2))))
  186.     ((string-match "\\(\\S-+@\\S-+\\) [(<]\\(.*\\)[>)]" x)
  187.      (cons (substring x (match-beginning 2) (match-end 2))
  188.            (substring x (match-beginning 1) (match-end 1))))
  189.     ((string-match "\\S-+@\\S-+" x)
  190.      (cons nil x))
  191.     (t
  192.      (cons x nil))))
  193.  
  194. (defun lm-authors (&optional file)
  195.   ;; Return the buffer's or FILE's author list.  Each element of the
  196.   ;; list is a cons; the car is a name-aming-humans, the cdr an email
  197.   ;; address.
  198.   (save-excursion
  199.     (if file
  200.     (find-file file))
  201.     (let ((authorlist (lm-header-multiline "author")))
  202.       (prog1
  203.      (mapcar 'lm-crack-address authorlist)
  204.       (if file
  205.           (kill-buffer (current-buffer)))
  206.     ))))
  207.  
  208. (defun lm-maintainer (&optional file)
  209.   ;; Get a package's bug-report & maintenance address.  Parse it out of FILE,
  210.   ;; or the current buffer if FILE is nil.
  211.   ;; The return value is a (name . address) cons.
  212.   (save-excursion
  213.     (if file
  214.     (find-file file))
  215.     (prog1
  216.     (let ((maint (lm-header "maintainer")))
  217.       (if maint
  218.           (lm-crack-address maint)
  219.         (car (lm-authors))))
  220.       (if file
  221.       (kill-buffer (current-buffer)))
  222.       )))
  223.  
  224. (defun lm-creation-date (&optional file)
  225.   ;; Return a package's creation date, if any.  Parse it out of FILE,
  226.   ;; or the current buffer if FILE is nil.
  227.   (save-excursion
  228.     (if file
  229.     (find-file file))
  230.     (prog1
  231.     (lm-header "created")
  232.       (if file
  233.       (kill-buffer (current-buffer)))
  234.       )))
  235.  
  236.  
  237. (defun lm-last-modified-date (&optional file)
  238.   ;; Return a package's last-modified date, if you can find one.
  239.   (save-excursion 
  240.     (if file
  241.     (find-file file))
  242.     (prog1
  243.     (if (progn
  244.           (goto-char (point-min))
  245.           (re-search-forward
  246.            "\\$Id: [^ ]+ [^ ]+ \\([^/]+\\)/\\([^/]+\\)/\\([^ ]+\\) "
  247.            (lm-code-mark) t))
  248.         (format "%s %s %s"
  249.             (buffer-substring (match-beginning 3) (match-end 3))
  250.             (nth (string-to-int 
  251.               (buffer-substring (match-beginning 2) (match-end 2)))
  252.              '("" "Jan" "Feb" "Mar" "Apr" "May" "Jun"
  253.                "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"))
  254.             (buffer-substring (match-beginning 1) (match-end 1))
  255.             ))
  256.       (if file
  257.       (kill-buffer (current-buffer)))
  258.       )))
  259.  
  260. (defun lm-version (&optional file)
  261.   ;; Return the package's version field.
  262.   ;; If none, look for an RCS or SCCS header to crack it out of.
  263.   (save-excursion 
  264.     (if file
  265.     (find-file file))
  266.     (prog1
  267.     (or
  268.      (lm-header "version")
  269.      (let ((header-max (lm-code-mark)))
  270.        (goto-char (point-min))
  271.        (cond
  272.         ;; Look for an RCS header
  273.         ((re-search-forward "\\$Id: [^ ]+ \\([^ ]+\\) " header-max t)
  274.          (buffer-substring (match-beginning 1) (match-end 1)))
  275.  
  276.         ;; Look for an SCCS header
  277.         ((re-search-forward 
  278.           (concat
  279.            (regexp-quote "@(#)")
  280.            (regexp-quote (file-name-nondirectory (buffer-file-name)))
  281.            "\t\\([012345679.]*\\)")
  282.           header-max t)
  283.          (buffer-substring (match-beginning 1) (match-end 1)))
  284.  
  285.         (t nil))))
  286.       (if file
  287.       (kill-buffer (current-buffer)))
  288.       )))
  289.  
  290. (defun lm-keywords (&optional file)
  291.   ;; Return the header containing the package's topic keywords.
  292.   ;; Parse them out of FILE, or the current buffer if FILE is nil.
  293.   (save-excursion
  294.     (if file
  295.     (find-file file))
  296.     (prog1
  297.     (let ((keywords (lm-header "keywords")))
  298.       (and keywords (downcase keywords)))
  299.       (if file
  300.       (kill-buffer (current-buffer)))
  301.       )))
  302.  
  303. (defun lm-adapted-by (&optional file)
  304.   ;; Return the name or code of the person who cleaned up this package
  305.   ;; for distribution.  Parse it out of FILE, or the current buffer if
  306.   ;; FILE is nil.
  307.   (save-excursion
  308.     (if file
  309.     (find-file file))
  310.     (prog1
  311.     (lm-header "adapted-by")
  312.       (if file
  313.       (kill-buffer (current-buffer)))
  314.       )))
  315.  
  316. (defun lm-commentary (&optional file)
  317.   ;; Return the commentary region of a file, as a string."
  318.   (save-excursion
  319.     (if file
  320.     (find-file file))
  321.     (prog1
  322.     (let ((commentary (lm-section-mark "Commentary" t))
  323.           (change-log (lm-section-mark "Change Log"))
  324.           (code (lm-section-mark "Code")))
  325.       (and commentary
  326.           (if change-log
  327.           (buffer-substring commentary change-log)
  328.         (buffer-substring commentary code)))
  329.       )
  330.       (if file
  331.       (kill-buffer (current-buffer)))
  332.       )))
  333.  
  334. ;;; Verification and synopses
  335.  
  336. (defun insert-at-column (col &rest pieces)
  337.    (if (> (current-column) col) (insert "\n"))
  338.    (move-to-column-force col)
  339.    (apply 'insert pieces))
  340.  
  341. (defconst lm-comment-column 16)
  342.  
  343. (defun lm-verify (&optional file showok)
  344.   "Check that the current buffer (or FILE if given) is in proper format.
  345. If FILE is a directory, recurse on its files and generate a report into
  346. a temporary buffer."
  347.   (if (and file (file-directory-p file))
  348.       (progn
  349.     (switch-to-buffer (get-buffer-create "*lm-verify*"))
  350.     (erase-buffer)
  351.     (mapcar
  352.      '(lambda (f)
  353.         (if (string-match ".*\\.el$" f)
  354.         (let ((status (lm-verify f)))
  355.           (if status
  356.               (progn
  357.             (insert f ":")
  358.             (insert-at-column lm-comment-column status "\n"))
  359.             (and showok
  360.              (progn
  361.                (insert f ":")
  362.                (insert-at-column lm-comment-column "OK\n")))))))
  363.     (directory-files file))
  364.     )
  365.   (save-excursion
  366.     (if file
  367.     (find-file file))
  368.     (prog1
  369.     (cond
  370.      ((not (lm-summary))
  371.       "Can't find a package summary")
  372.      ((not (lm-code-mark))
  373.       "Can't find a code section marker")
  374.      ((progn
  375.         (goto-char (point-max))
  376.         (forward-line -1)
  377.         (looking-at (concat ";;; " file "ends here")))
  378.       "Can't find a footer line")
  379.      )
  380.       (if file
  381.       (kill-buffer (current-buffer)))
  382.       ))))
  383.  
  384. (defun lm-synopsis (&optional file showall)
  385.   "Generate a synopsis listing for the buffer or the given FILE if given.
  386. If FILE is a directory, recurse on its files and generate a report into
  387. a temporary buffer.  If SHOWALL is on, also generate a line for files
  388. which do not include a recognizable synopsis."
  389.   (if (and file (file-directory-p file))
  390.       (progn
  391.     (switch-to-buffer (get-buffer-create "*lm-verify*"))
  392.     (erase-buffer)
  393.     (mapcar
  394.      '(lambda (f)
  395.         (if (string-match ".*\\.el$" f)
  396.         (let ((syn (lm-synopsis f)))
  397.           (if syn
  398.               (progn
  399.             (insert f ":")
  400.             (insert-at-column lm-comment-column syn "\n"))
  401.             (and showall
  402.              (progn
  403.                (insert f ":")
  404.                (insert-at-column lm-comment-column "NA\n")))))))
  405.      (directory-files file))
  406.     )
  407.     (save-excursion
  408.       (if file
  409.       (find-file file))
  410.       (prog1
  411.       (lm-summary)
  412.     (if file
  413.         (kill-buffer (current-buffer)))
  414.     ))))
  415.  
  416. (defun lm-report-bug (topic)
  417.   "Report a bug in the package currently being visited to its maintainer.
  418. Prompts for bug subject.  Leaves you in a mail buffer."
  419.   (interactive "sBug Subject: ")
  420.   (let ((package (buffer-name))
  421.     (addr (lm-maintainer))
  422.     (version (lm-version)))
  423.     (mail nil (or addr bug-gnu-emacs) topic)
  424.     (goto-char (point-max))
  425.     (insert "\nIn "
  426.         package
  427.         (and version (concat " version " version))
  428.         "\n\n")
  429.     (message
  430.      (substitute-command-keys "Type \\[mail-send] to send bug report."))))
  431.  
  432. (provide 'lisp-mnt)
  433.  
  434. ;;; lisp-mnt.el ends here
  435.